;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
#||
			RESTRICTED RIGHTS LEGEND
				    
 Use, duplication, or disclosure by the Government is subject to
 restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
 Technical Data and Computer Software Clause at 52.227-7013 of the DOD
 FAR Supplement.
				    
				TSP (The Software Partnership)
				P.O. Box 991
				Melrose, MA 02176
				    
      Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
||#
 
(in-package :ooga)



;************************************************************

;	 DRIVER FUNCTION


;;; TO RUN ANY OF THE EXAMPLES, USE
;;; (trial-run <example-name>)

;;;  EXAMPLE:   to see an example of GA 1-1, use
;;;     (trial-run 'ga-1-1)

(defun TRIAL-RUN (genetic-algorithm-type)
  (setf *ga* (make-instance genetic-algorithm-type))
  (run *ga*))


;************************************************************

;	 TEST GA

;;; Use this GA to determine whether OOGA has loaded.  After
;;; loading, type (trial-run 'test-ga) into Lisp.  If all is
;;; well, the test GA will run for 40 evaluations and stop with
;;; a display of the top five chromosomes in the population.

(defclass TEST-GA (ga-1-1) ())


(def-append-method GET-PARTICULARS ((ga test-ga))
    `((population-size 10)
      (desired-trials 40)))
	

;************************************************************

;	FIRST INHERITANCE HIERARCHY

;************************************************************

;	GA-1-1

;; GA-1-1 is the basic GA that GA's 1-2 through 3-4 will be
;; built on.

(defclass GA-1-1 (basic-genetic-algorithm) ())

;;; We don't use any component GA with slot values.  
;;; Fill in the particulars.
(def-append-method GET-PARTICULARS ((ga ga-1-1))
    `((evaluator ,(make-instance 'binary-f6))
      (population-size 100)
      (desired-trials 4000)
      (fitness-technique ,(make-instance 'fitness-is-evaluation))
      (parent-selection-technique
	,(make-instance 'roulette-wheel-parent-selection))
      (representation-technique
	,(make-instance 'binary-representation
			:bit-string-length 44))
      (initialization-technique
	,(make-instance 'random-binary-initialization))
      (reproduction-technique
	,(make-instance 'generational-replacement))
      (deletion-technique ,(make-instance 'delete-all))
      (operator-selection-technique
	,(make-instance 'use-first-operator))
      (operator-list
	,(list (make-instance 'one-point-crossover-and-mutate)))))


;************************************************************

;	GA-2-1


(defclass GA-2-1 (ga-1-1) ())

;;; Replace fitness-is-evaluation with linear-normalization
(def-append-method GET-PARTICULARS ((ga ga-2-1))
    `((fitness-technique
	,(make-instance 'linear-normalization))))


;************************************************************

;	GA-2-2

(defclass GA-2-2 (ga-2-1) ())

;;; Add elitism to generational replacement
(def-append-method GET-PARTICULARS ((ga ga-2-2))
    `((reproduction-technique
	,(make-instance 'generational-replacement-with-elitism))))


;************************************************************

;	GA-2-3

(defclass GA-2-3 (ga-2-1) ())

;;; Replace generational replacement with steady-state reproduction
(def-append-method GET-PARTICULARS ((ga ga-2-3))
    `((reproduction-technique ,(make-instance 'steady-state))
      (deletion-technique ,(make-instance 'delete-last))))


;************************************************************

;	GA-2-4

(defclass GA-2-4 (ga-2-3) ())

;;; Add no duplicates to steady state.
(def-append-method GET-PARTICULARS ((ga ga-2-4))
    `((reproduction-technique
	,(make-instance 'steady-state-without-duplicates))))


;************************************************************

;	GA-2-5

(defclass GA-2-5 (ga-2-4) ())

;;; Increase mutation and crossover rates in basic operator
(def-append-method GET-PARTICULARS ((ga ga-2-5))
    `((operator-list
	,(list (make-instance 'one-point-crossover-and-mutate
			      :bit-mutation-rate .04
			      :crossover-rate .8)))))


;************************************************************

;	RANDOM BINARY-F6

;;;  (used for tests of random generate and search)


(defclass RANDOM-BINARY-F6
	  (ga-2-5)
     ())

;;; Generate random individuals rather than using existing parents.
(def-append-method GET-PARTICULARS ((ga random-binary-f6))
    `((operator-list
	,(list (make-instance 'random-bit-string-generation)))
      (operator-weights '(100))))


;************************************************************

;	GA-3-1

;;; GA 3-1 is a steady-state binary f6 GA.  It is the GA that 
;;; GA's 3-2 through 3-4 will be built on.


(defclass GA-3-1 (ga-2-4) ())

;;; Separate the two operators
(def-append-method GET-PARTICULARS ((ga ga-3-1))
    `((operator-list
	,(list (make-instance 'one-point-crossover)
	       (make-instance 'binary-mutation
			      :bit-mutation-rate .04)))
      (operator-weights ,(list 60 40))))


;************************************************************

;	GA-3-2


(defclass GA-3-2 (ga-3-1) ())

;;; Replace two-point crossover with uniform crossover.
(def-append-method GET-PARTICULARS ((ga ga-3-2))
    `((operator-list
	,(list (make-instance 'uniform-list-crossover)
	       (make-instance 'binary-mutation
			      :bit-mutation-rate .04)))))


;************************************************************


;	GA-3-3


(defclass GA-3-3
	  (ga-3-2)
     ())

;;; Interpolate operator weights
(def-append-method GET-PARTICULARS ((ga ga-3-3))
    `((reproduction-parameterization-techniques
	,(list (make-instance 'interpolate-operator-weights
			      :interpolation-specs '((70 30) (50 50)))))))



;************************************************************

;	GA-3-4


(defclass GA-3-4
	  (ga-3-3)
     ())

;;; Interpolate the fitness decrement
(def-append-method GET-PARTICULARS ((ga ga-3-4))
    `((population-parameterization-techniques
	,(list (make-instance
		 'interpolate-fitness-decrement)))))


;************************************************************

;	SECOND GA HIERARCHY

;************************************************************

;	GA-5-1

;;; GA 5-1 is a real-valued GA.
(defclass GA-5-1 (basic-genetic-algorithm) ())

;;; We're not using a component GA in the tutorial, so we'll build
;;; this GA from scratch.
(def-append-method GET-PARTICULARS ((ga ga-5-1))
    `((evaluator ,(make-instance 'real-number-f6))
      (population-size 100)
      (desired-trials 4000)
      (fitness-technique ,(make-instance 'linear-normalization))
      (parent-selection-technique
	,(make-instance 'roulette-wheel-parent-selection))
      (representation-technique
	,(make-instance 'real-number-representation))
      (initialization-technique
	,(make-instance 'random-real-number-initialization))
      (reproduction-technique
	,(make-instance 'steady-state-without-duplicates))
      (deletion-technique ,(make-instance 'delete-last))
      (population-parameterization-techniques
	,(list (make-instance 'interpolate-fitness-decrement)))
      (operator-selection-technique
	,(make-instance 'roulette-wheel-operator-selection))
      (operator-list
	,(list (make-instance 'uniform-list-crossover)
	    (make-instance 'average-crossover)
	    (make-instance 'real-number-mutation)
	    (make-instance 'real-number-creep
			   :creep-specs '((70000 t)))
	    (make-instance 'real-number-creep
			   :creep-specs '((2000 t)))))
      (operator-weights ,(list 10 40 10 30 10))
      (reproduction-parameterization-techniques
	,(list (make-instance
	      'interpolate-operator-weights
	      :interpolation-specs
	      '((10 40 10 30 10) (10 20 0 40 30)))))))


;************************************************************

;	GA 6-1

;;; GA 6-1 is the node-coloring order-based GA.
;;; It shares some of the techniques of GA-5-1.
(defclass GA-6-1 (ga-5-1) ())

;;; Particularize for the node-coloring problem.
(def-append-method GET-PARTICULARS ((ga ga-6-1))
    `((evaluator ,(make-instance 'node-coloring-evaluator))
      (representation-technique ,(make-instance 'permuted-list))
      (initialization-technique ,(make-instance 'random-permutation))
      (operator-list
	,(list (make-instance 'uniform-order-based-crossover)
	       (make-instance 'scramble-sublist-mutation)))
      (operator-weights '(60 40))
      (reproduction-parameterization-techniques
	,(list (make-instance
		 'interpolate-operator-weights
		 :interpolation-specs '((70 30) (50 50)))))))


;;; Need new display method for displaying the best solution.
(defmethod DISPLAY-BEST-SOLUTION ((ga ga-6-1))
  (format *standard-output* "~%~%BEST SOLUTION HAS EVALUATION ~A"
	  (evaluation (first-member (population-module ga))))
  (loop for node in (chromosome (first-member (population-module ga)))
	do (format *standard-output* "~%~a  ~a  ~a"
		   (index node) (weight node) (color node))))


;************************************************************

;	RANDOM NODE-COLORING

;;; A benchmark for comparison.  This GA just generates random
;;; permutations of the node list.
(defclass RANDOM-NODE-COLORING (ga-6-1) ())

;;; Only use the random generation operator.  Ignore parents.
(def-append-method GET-PARTICULARS ((ga random-node-coloring))
    `((operator-list ,(list (make-instance 'random-order-generation)))
      (operator-weights ,(list 100))
      (population-parameterization-techniques nil)
      (reproduction-parameterization-techniques nil)))


;************************************************************

;;;	GA 7-1 -- ADAPTS OPERATOR WEIGHTS FOR GA 5-1 AND FINDS
;;;	GOOD INITIAL WEIGHT LISTS


;;; Use (find-initial-operator-weights (make-instance 'ga-7-1))
;;; to see the system find appropriate starting operator weights.

;;; NOTE: The weights found should differ from those in the Handbook.
;;; The Handbook algorithm has been replaced by a better one here.
;;; This algorithm finds weights in the vicinity of (10 55 15 15 5).


;;; Use (trial-run 'ga-7-1) to see the weights adapt during a run.


(defclass GA-7-1
	  (ga-5-1 adapt-initial-operator-weights) ()
     (:default-initargs
       :population-module (make-instance 'population-module-7-1)
       :reproduction-module (make-instance 'reproduction-module-7-1)))
       

(defclass POPULATION-MODULE-7-1
	  (trace-operator-weights
 	    adaptive-operator-module
	    basic-population-module)
     ())


(defclass REPRODUCTION-MODULE-7-1
	  (adaptive-reproduction-module) ())


(def-append-method GET-PARTICULARS ((ga ga-7-1))
    `((population-member-class adaptation-population-member)
      (reproduction-parameterization-techniques nil)
      (initial-operator-weights (10 40 10 30 10))))


;************************************************************

;	PERFORMANCE GRAPHS

(defun GET-NINE-COUNT-STATISTICS (ga-type &optional (runs 20))
  (setf *ga* (make-instance ga-type))
  (setf (display-flag (population-module *ga*)) nil)
  (format t "~%PERFORMANCE RUN OF ~A:" ga-type)
  (loop for x from 1 to runs do (format t "  ~a"  x)
			      (run *ga*))
  (format t "~%~%NINE-COUNT PERFORMANCE:")
  (loop for stat in (reverse (average-nines-performance (population-module *ga*)))
	do (format t "~%~a  ~a" (car stat) (cadr stat))))


(defun GET-PERFORMANCE-STATISTICS (ga-type &optional (runs 20))
  (setf *ga* (make-instance ga-type))
  (setf (display-flag (population-module *ga*)) nil)
  (format t "~%PERFORMANCE RUN OF ~A:" ga-type)
  (loop for x from 1 to runs do (format t "  ~a"  x)
			      (run *ga*))
  (format t "~%~%PERFORMANCE:")
  (loop for stat in (reverse (average-performance (population-module *ga*)))
	do (format t "~%~a  ~a" (car stat) (cadr stat))))


(defmethod AVERAGE-NINES-PERFORMANCE ((population-module basic-population-module))
  (let* ((list (performance-statistics population-module))
	 (length (length list))
	 (nine-totals (sum-nine-cadrs list)))
    (loop for x in nine-totals
	  collect (list (car x) (/ (cadr x) (float length))))))


(defun SUM-NINE-CADRS (list)
  "Sum the decimal nines in cadrs of parallel conses across the lists in the list"
  (loop for sublist in (cdr list)
	with sum = (loop for item in (car list)
			 collect (list (car item) (count-decimal-nines (cadr item))))
	do (loop for item in sublist
		 for total in sum
		 do (setf (cadr total) (+ (cadr total) (count-decimal-nines (cadr item)))))
	finally (return sum)))


(defun GA-1-1-AVERAGE ()
  (declare (special g))
  (setf g (make-instance 'ga-1-1))
  (setf (display-flag (population-module g)) nil)
  (run g)
  (loop for x below 20 with mini = nil with maxi = nil with av = nil
	do (initialize-population (population-module g))
	(format t "  ~a" x)
	(setf mini (cons (apply 'min (evaluations (population-module g))) mini)
	      maxi (cons (apply 'max (evaluations (population-module g))) maxi)
	      av (cons (average (evaluations (population-module g))) av))
	finally (format t "~%~%MIN ~a   Max  ~a  Av  ~a"
			(average mini) (average maxi) (average av))))


;************************************************************

;	RANDOM GENERATION OF BIT STRINGS FOR F6


(defclass GA-F6-RANDOM
	  (ga-2-3)
     ())


(defmethod INITIALIZE-INSTANCE :AFTER ((ga ga-f6-random) &rest args)
  (declare (ignore args))
  (setf (operator-list (reproduction-module ga))
		       (list (make-instance 'random-bit-string-generation)))
  (setf (operator-selection-technique (reproduction-module ga))
	(make-instance 'use-first-operator)))



;************************************************************

;	RANDOM GENERATION OF PERMUTATIONS FOR NODE COLORING


(defclass GA-NODE-COLOR-RANDOM
	  (ga-6-1)
     ())


(defmethod INITIALIZE-INSTANCE :AFTER ((ga ga-node-color-random) &rest args)
  (declare (ignore args))
  (setf (operator-list (reproduction-module ga))
		       (list (make-instance 'random-order-generation)))
  (setf (operator-selection-technique (reproduction-module ga))
	(make-instance 'use-first-operator)))
